home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / tvtoys04.zip / FONTFILE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-12-15  |  10KB  |  345 lines
  1. (***************************************************************************
  2.   FontFiles unit
  3.   Font file loading and scanning
  4.   PJB November 3, 1993, Internet mail to d91-pbr@nada.kth.se
  5.   Copyright 1993, All Rights Reserved
  6.   Free source, use at your own risk.
  7.   If modified, please state so if you pass this around.
  8.  
  9.   Load and save font files to/from disk. A font can be up to 32 scanlines
  10.   high on a VGA, 14 on an EGA.
  11.  
  12.   WARNING! A font object is 8 Kb large, if you have two local variable
  13.   fonts, you should get a stack overflow error. Make sure you set stack
  14.   overflow checking to true before you fiddle with font objects, or
  15.   allocate them on the heap instead.
  16.  
  17.   Bug: You can't use DoWrite in protected mode, but why should you?
  18.  
  19. ***************************************************************************)
  20. unit FontFiles;
  21. {$B-,O+,V-,X+}
  22.  
  23. interface
  24.  
  25.   uses
  26.     MsgBox, Objects,
  27.     Dos,
  28.     toyPrefs, toyUtils, TVVideo;
  29.  
  30.   const
  31.     MaxFontHeight = 32;   (* Height in scanlines. Max 32 (EGA 14) *)
  32.  
  33.   type
  34.     ScanProcedure = procedure(Height:Integer; const Desc, FileName:String);
  35.  
  36.     FontDataArray = array [0..256*MaxFontHeight] of Byte;
  37.  
  38.     PFontFile = ^TFontFile;
  39.     TFontFile =
  40.       object (TObject)
  41.         Name   : PathStr;
  42.         Desc   : String[80];
  43.         Height : Integer;
  44.         Data   : FontDataArray;
  45.  
  46.         constructor Load(var St:TStream);
  47.         procedure DiskScan(const Path:String; Proc:ScanProcedure);
  48.         procedure Display;
  49.         function  DoRead(const Path:String):Boolean;
  50.         function  DoWrite:Boolean;
  51.         function  Read(const Path:String):Boolean;
  52.         function  Write:Boolean;
  53.         procedure Store(var St:TStream);
  54.  
  55.       private
  56.  
  57.         S        : TDosStream;
  58.         FontOfs  : Word;
  59.         FileType : Integer;
  60.         procedure CalcType(var Buf);
  61.         procedure Close;
  62.         procedure GetFont;
  63.         procedure GetInfo;
  64.         procedure MakeDesc(var aDesc:String);
  65.         procedure Open(aName:String);
  66.       end;
  67.  
  68.  
  69. (***************************************************************************
  70. ***************************************************************************)
  71. implementation
  72.  
  73.   const
  74.     COMDescOfs  = 2+18;
  75.     DescLen     = 61;
  76.     COMPointOfs = COMDescOfs+DescLen;
  77.     COMFontOfs  = COMPointOfs+1;
  78.  
  79.  
  80.   (*******************************************************************
  81.     This is what is written as a font preamble to make it a working
  82.     COM file. This is the first procedure in this segment, so code
  83.     begins at offset 0
  84.   *******************************************************************)
  85.   procedure ComAsm; assembler;
  86.   asm
  87.       jmp  @Init                         {  2 bytes }
  88.       db   13,'StickyFont Font',13,10    { 18 bytes }
  89.  
  90.     @Desc:
  91.       dd   0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0
  92.       db   26
  93.  
  94.     @Points:
  95.       db   0
  96.     @Font:
  97.       dw   100h + OFFSET @ComEnd
  98.  
  99.     @Init:
  100.       mov  bh,[100h + OFFSET @Points]
  101.       mov  ax,1110h
  102.       mov  cx,256
  103.       xor  dx,dx
  104.       mov  bl,dl
  105.       mov  bp,[100h + OFFSET @Font]
  106.       int  10h
  107.       int  20h
  108.     @ComEnd:
  109.   end;
  110.  
  111.   procedure ComEnd; assembler; asm end;
  112.  
  113.  
  114.     (*******************************************************************
  115.     *******************************************************************)
  116.  
  117.   type
  118.     MagicArray = array [0..3] of LongInt;
  119.     FontFileInfo =
  120.       record
  121.         HeightOfs : word;
  122.         FontOfs   : word;
  123.         Magic     : ^MagicArray;
  124.       end;
  125.  
  126.   const
  127.     FileTypes = 3;
  128.     FE1 : MagicArray = ($D9033EB, $D202020, $6370200A, $67616D20);
  129.     FE2 : MagicArray = ($D01B7E9, $D202020, $63694D0A, $6C656168);
  130.     FontFileArr : array [1..FileTypes] of FontFileInfo = (
  131.       (HeightOfs:$32; FontOfs:$62; Magic:@FE1),
  132.       (HeightOfs:$23; FontOfs:$62; Magic:@FE2),
  133.       (HeightOfs: COMPointOfs; FontOfs: COMFontOfs; Magic:@ComAsm));
  134.  
  135.  
  136. (***************************************************************************
  137. ***************************************************************************)
  138.  
  139.   (*******************************************************************
  140.     Stream constructor
  141.   *******************************************************************)
  142.   constructor TFontFile.Load(var St:TStream);
  143.   begin
  144.     inherited Init;
  145.     St.Read(Name, SizeOf(Name)+SizeOf(Desc)+SizeOf(Height));
  146.     St.Read(Data, Height*256);
  147.   end;
  148.  
  149.  
  150.   (*******************************************************************
  151.     Match the font file against known types
  152.   *******************************************************************)
  153.   procedure TFontFile.CalcType;
  154.   begin
  155.     FileType:=1;
  156.     while (FileType<=FileTypes) and not
  157.           MemComp(FontFileArr[FileType].Magic^, Buf, SizeOf(MagicArray)) do
  158.       Inc(FileType);
  159.  
  160.     if FileType>FileTypes then
  161.       FileType:=0;
  162.   end;
  163.  
  164.  
  165.   (*******************************************************************
  166.     Close font stream
  167.   *******************************************************************)
  168.   procedure TFontFile.Close;
  169.   begin
  170.     S.Done;
  171.   end;
  172.  
  173.  
  174.   (*******************************************************************
  175.     Scan directory for font files
  176.   *******************************************************************)
  177.   procedure TFontFile.DiskScan;
  178.     var
  179.       SR   : SearchRec;
  180.   begin
  181.     FindFirst(AddBackSlash(Path)+'*.COM', Archive+ReadOnly+Hidden, SR);
  182.     while DosError=0 do
  183.     begin
  184.       Open(Path+SR.name);
  185.       Close;
  186.       if Height>0 then
  187.         Proc(Height, Desc+','+ToStr(Height)+'p', SR.Name);
  188.       FindNext(SR);
  189.     end;
  190.   end;
  191.  
  192.  
  193.   (*******************************************************************
  194.     Change the screen font
  195.   *******************************************************************)
  196.   procedure TFontFile.Display;
  197.   begin
  198.     TVVideo.SetUserFont(Height, @Data);
  199.   end;
  200.  
  201.  
  202.   (*******************************************************************
  203.     Open and read font from file
  204.   *******************************************************************)
  205.   function TFontFile.DoRead;
  206.   begin
  207.     Open(Path);
  208.     GetFont;
  209.     DoRead:=(S.Status=stOK) and (Height>0);
  210.     Close;
  211.   end;
  212.  
  213.  
  214.   (*******************************************************************
  215.     Write a COM file that sets the font when run
  216.   *******************************************************************)
  217.   function TFontFile.DoWrite;
  218.   begin
  219.     Byte(Ptr(CSeg, Ofs(ComAsm)+COMPointOfs)^):=Height;
  220.  
  221.     if Desc='' then
  222.       MakeDesc(Desc);
  223.     Byte(Desc[0]):=Min(Length(Desc)+1, 61);
  224.     Desc[Length(Desc)]:=#26;
  225.     Move(Desc[1], Ptr(CSeg, Ofs(ComAsm)+COMDescOfs)^, Length(Desc));
  226.  
  227.     S.Init(Name, stCreate);
  228.     S.Write(@ComAsm^, Ofs(ComEnd)-Ofs(ComAsm)-1);
  229.     S.Write(Data, Height*256);
  230.     S.Done;
  231.  
  232.     DoWrite:=S.Status=stOK;
  233.   end;
  234.  
  235.  
  236.   (*******************************************************************
  237.     Read the font's bitmap from disk
  238.   *******************************************************************)
  239.   procedure TFontFile.GetFont;
  240.   begin
  241.     if Height<=MaxFontHeight then
  242.     begin
  243.       S.Seek(FontOfs);
  244.       S.Read(Data, Height*256);
  245.     end;
  246.   end;
  247.  
  248.  
  249.   (*******************************************************************
  250.     Get font info from file
  251.   *******************************************************************)
  252.   procedure TFontFile.GetInfo;
  253.     var
  254.       Buf : array [0..127] of Byte;
  255.   begin
  256.     S.Read(Buf, SizeOf(Buf));
  257.     if S.Status=stOK then
  258.     begin
  259.       CalcType(Buf);
  260.  
  261.       if FileType<>0 then
  262.       begin
  263.         Height:=Buf[FontFileArr[FileType].HeightOfs];
  264.         if Height>32 then
  265.           Height:=0;
  266.         FontOfs:=FontFileArr[FileType].FontOfs;
  267.       end;
  268.  
  269.       if FileType=3 then
  270.       begin
  271.         FontOfs:=Buf[FontOfs];
  272.         Move(Buf[COMDescOfs], Desc[1], DescLen+1);
  273.         Desc[0]:=Chr(DescLen);
  274.         Desc[0]:=Chr(Pos(#26, Desc)-1);
  275.       end
  276.       else
  277.         MakeDesc(Desc);
  278.     end
  279.   end;
  280.  
  281.  
  282.   (*******************************************************************
  283.     If there is no description, make one out of the base file name
  284.     Only StickyFont (Far Niente) files have descriptions
  285.   *******************************************************************)
  286.   procedure TFontFile.MakeDesc(var aDesc:String);
  287.     var
  288.       Dir : DirStr;
  289.       Ext : ExtStr;
  290.   begin
  291.     FSplit(Name, Dir, aDesc, Ext);
  292.   end;
  293.  
  294.  
  295.   (*******************************************************************
  296.     Open font file and read info
  297.   *******************************************************************)
  298.   procedure TFontFile.Open;
  299.   begin
  300.     Name:=aName;
  301.     S.Init(Name, stOpenRead);
  302.     FileType:=0;
  303.     Height:=0;
  304.     GetInfo;
  305.   end;
  306.  
  307.  
  308.   (*******************************************************************
  309.     Try to read a font from disk
  310.   *******************************************************************)
  311.   function TFontFile.Read;
  312.   begin
  313.     Read:=False;
  314.     if DoRead(Path) then
  315.       Read:=True
  316.     else
  317.       MessageBox(^C'Error reading font', Nil, mfError+mfOKButton);
  318.   end;
  319.  
  320.  
  321.   (*******************************************************************
  322.     Stream storing
  323.   *******************************************************************)
  324.   procedure TFontFile.Store(var St:TStream);
  325.   begin
  326.     St.Write(Name, SizeOf(Name)+SizeOf(Desc)+SizeOf(Height));
  327.     St.Write(Data, Height*256);
  328.   end;
  329.  
  330.  
  331.   (*******************************************************************
  332.     Try to write a COM file
  333.   *******************************************************************)
  334.   function TFontFile.Write;
  335.   begin
  336.     if not DoWrite then
  337.       MessageBox(^C'Error writing font', Nil, mfError+mfOKButton);
  338.   end;
  339.  
  340.  
  341.     (*******************************************************************
  342.     *******************************************************************)
  343.  
  344. end.
  345.